00100	TITLE SALISP  -  SAIL Accessible LISP  -  November 1972.
00200	
00300	;storage allocation map.
00400	
00500		orgLSP: . 	;LISP interpreter.
00600		sizLSP:	efolst-.-1
00700		endLSP: efolst-1
00800	
00900		orgBPS: 0	;Binary Program Space.
01000		sizBPS:	2000
01100		endBPS: 0
01200		
01300		orgHWS: 0	;Half Word Space.
01400		sizHWS:	0
01500		endHWS: 0
01600	
01700		orgFWS: 0	;Full Word Space.
01800		sizFWS:	1000
01900		endFWS: 0
02000	
02100		orgHBT: 0	;Halfwords Bit Tables.
02200		sizHBT:	0
02300		endHBT: 0
02400	
02500		orgFBT: 0	;Fullwords Bit Table
02600		sizFBT:	0
02700		endFBT: 0
02800		
02900		orgPDL: 0	;regular PDL.
03000		sizPDL:	1000
03100		endPDL: 0
03200	
03300		orgSPD: 0	;special PDL.
03400		sizSPD:	1000
03500		endSPD: 0
     

00100	;SAIL JOBDAT ADDRESSES.
00150	
00200		SAI41:	0
00300		SAIAPR:	0
00350	
00400	;SAIL ACCUMULATORS.
00450		for @' i←0,17{AC'i: 0↔}
02050	
02100	;LISP ACCUMULATORS.
02150	
02200		LISPAC:	BLOCK 20
02300	
02400	;Olde switch and pointers.
02450	
02600		RETFLG:	0
02700		BSFLG:	0	;Boot Strape initialization done.
     

00100	SUBTTL AC DEFINITIONS AND EXTERNALS 		--- PAGE 1
00200		INUMIN←377777
00300		INUM0←<INUMIN+777777>/2
00400		BCKETS←←177
00500	
00600	;accumulator definitions
00700	;`sacred' means sacred to the interpreter
00800	;`marked' means marked from by the garbage collector
00900	;`protected' means protected during garbage collection
01000	
01100	↓NIL←0	;sacred, marked, protected	;atom head of NIL
01200	↓A←1	;marked, protected	;1st arg & function result.
01300	↓B←A+1	;marked, protected	;second arg of subrs
01400	↓C←B+1	;marked, protected	;third arg of subrs
01500	↓AR1←4	;marked, protected	;fourth arg of subrs
01600	↓AR2A←5	;marked, protected	;fifth arg of subrs
01700	↓T←6	;marked, protected	;minus number of args in LSUBR call
01800	↓TT←7	;marked, protected
01900	↓REL←10	;marked, protected	;rarely used
02000	↓S←11	;rarely used
02100	↓D←12	
02200	↓R←13	;protected
02300	↓P←14	;sacred, protected	;regular push down stack pointer
02400	↓F←15	;sacred	;free storage list pointer
02500	↓FF←16	;sacred	;full word list pointer
02600	↓SP←17	;sacred, protected	;special pushdown stack pointer
02700	
02800	NACS←←5	;number of argument acs
02900	
03000	X←←0	;X indicates impure (modified) code locations
03100	TEN←←=10
     

00100	;ALTERNATE PDP-10 MNEMONICS.
00200	
00300		OPDEF LIP[HLR]
00400		OPDEF LAP[HRR]
00500		OPDEF DIP[HRLM]
00600		OPDEF DAP[HRRM]
00700		
00800		OPDEF CAR[HLRZ]
00900		OPDEF CDR[HRRZ]
01000		OPDEF DIPZ[HRLZM]
01100		OPDEF DAPZ[HRRZM]
01200	
01300		OPDEF LAC[MOVE]
01400		OPDEF DAC[MOVEM]
01500		OPDEF LACN[MOVN]
01600		OPDEF DACN[MOVNM]
01700	
01800	;The foolst macro marks LISP Space References.
01900	
02000		DEFINE FOO <
02100		XLIST
02200			BAZ(→FOOCNT)
02300		LIST
02400			>
02500		
02600		DEFINE BAZ '(X)
02700		<FOOCNT←FOOCNT+1
02800		FOO'X:
02900		>
03000	
03100		FOOCNT←0
     

00100	;UUO definitions
00200	;UUOs used to call functions from compiled code
00300	;the number of arguments is given by the ac field 
00400	;the address is a pointer either to the function 
00500	;name or the code of the function
00600	
00700	OPDEF FCALL [34B8]	;ordinary function call, like PUSHJ
00800	OPDEF JCALL [35B8]	;terminal function call, like JRST
00900	OPDEF CALLF [36B8]	;like call but may not be changed to PUSHJ
01000	OPDEF JCALLF [37B8]	;like jcall but may not be changed to JRST
01100	
01200	;error UUOs 
01300	
01400	OPDEF ERR1 [1B8]	;ordinary lisp error	;gives backtrace
01500	OPDEF ERR2 [2B8]	;space overflow error	;no backtrace
01600	OPDEF ERR3 [3B8]	;ill. mem. ref.
01700	OPDEF STRTIP [4B8]	;print error message and continue
01800	
01900	;external and internal symbols
02000	
02100		EXTERNAL JOB41	;instruction to be executed on UUO
02200		EXTERNAL JOBAPR	;address of APR interupt routines
02300		EXTERNAL JOBCNI	;interupt condition flags
02400		EXTERNAL JOBFF	;first location beyond program
02500		EXTERNAL JOBREL	;top of core image.
02600		EXTERNAL JOBREN	;reentry address
02700		EXTERNAL JOBSA	;starting address
02800		EXTERNAL JOBSYM	;address of symbol table
02900		EXTERNAL JOBTPC	;program counter at time of interupt
03000		EXTERNAL JOBUUO	;uuo with its effective address.
03100	
03200	;apr flags
03300	
03400		PDOV←←200000	;push down list overflow
03500		MPV←←20000	;memory protection violation
03600		NXM←←10000	;non-existant memory referenced
03700		APRFLG←←PDOV+MPV+NXM	;any of the above
03800		
03900	;system uuos
04000		APRINI←←16
04100		RESET←←0
04200		STIME←←27
04300		DEVCHR←←4
04400		EXIT←←12
04500		CORE←←11
     

00100	;system UUOs
00200	
00300		OPDEF TTYUUO [51B8]
00400		OPDEF INCHRW [TTYUUO 0,]
00500		OPDEF OUTCHR [TTYUUO 1,]
00600		OPDEF OUTSTR [TTYUUO 3,]
00700		OPDEF INCHWL [TTYUUO 4,]
00800		OPDEF INCHSL [TTYUUO 5,]
00900		OPDEF CLRBFI [TTYUUO 11,]
01000		DEFINE TALK{PUSHJ P,TTYCLR}
01100	
01200	;I/O bits and constants
01300	
01400		TTYLL←←105	;teletype linelength 
01500		LPTLL←←160	;line printer linelength
01600		MLIOB←←203	;max length of I/O buffer
01700		NIOB←←2	;no of I/O buffers per device
01800		NIOCH←←7	;number of I/O channels
01900		FSTCH←←11	;first I/O channel
02000		TTCH←←10	;teletype I/O channel
02100		COUNT←←10
02200		BLKSIZE←←NIOB*MLIOB+COUNT+1
02300		INB←←2
02400		OUTB←←1
02500		AVLB←←40
02600		DIRB←←4
02700	
02800	;special ASCII characters
02900		ALTMOD←←175
03000		SPACE←←40	;space
03100		IGCRLF←←32	;ignored cr-lf
03200		RUBOUT←←177
03300		LF←←12
03400		CR←←15
03500		TAB←←11
03600		BELL←←7
03700		DBLQT←←42	;double quote "
03800	
03900	;byte pointer field definitions
04000		ACFLD←←14	;ac field
04100		XFLD←←21	;index field
04200		OPFLD←←10	;opcode field
04300		ADRFLD←←43	;adress field
04400		
     

     

00100	;ALLOCATION DIALOGUE SUBROUTINE.
00200	
00300	ALLOCD:	0
00400	
00500	OUTSTR [ASCIZ /
00600	ALLOC? /]
00700		INCHRW C
00800		CAIGE C,"O"
00900		JRST @ALLOCD
01000	
01100	OUTSTR [ASCIZ /
01200	FULL WDS=/]
01300		JSR ALLNUM
01400		SKIPGE A
01500		MOVEI A,400
01600		DAC A,sizFWS
01700	
01800	OUTSTR [ASCIZ /
01900	BIN.PROG.SP=/]
02000		JSR ALLNUM
02100		SKIPGE A
02200		MOVEI A,2000
02300		DAC A,sizBPS
02400	
02500	OUTSTR [ASCIZ /
02600	SPEC.PDL=/]
02700		JSR ALLNUM
02800		SKIPGE A
02900		MOVEI A,1000
03000		DAC A,sizSPD
03100	
03200	OUTSTR [ASCIZ /REG. PDL=
03300	/]
03400		JSR ALLNUM
03500		SKIPGE A
03600		MOVEI A,1000
03700		DAC A,sizPDL
03800		JRST @ALLOCD
03850	
03900	ALLNUM:	0
04000		MOVSI A,400000		;high bit on for no digits
04100		INCHRW C
04200		CAIN C,RUBOUT
04300		JRST	[OUTSTR [ASCIZ /XXX /]
04400			JRST ALLNUM+1]
04500		CAIL C,"0"
04600		CAILE C,"9"
04700		JRST @ALLNUM
04800		TLZ A,400000	;turn off hi bit on digit
04900		IMULI A,10
05000		ADDI A,-"0"(C)
05100		JRST ALLNUM+2
     

00100	;LISP TO SAIL.
00200	INTERN SAIL
00300	SAIL:	LAC SAI41
00400		DAC JOB41
00500		LAC SAIAPR
00600		DAC JOBAPR
00700		LAC 0,[XWD AC1,1]
00800		BLT 0,17
00900		LAC 0,AC0
01000		SUB 17,[XWD 2,2]
01100		JRST @2(17)
     

00100	;SAIL TO LISP.
00200		INTERN LISP
00300		EXTERN CORGET
00400	;ACCUMULATOR-2	POINTER TO FIRST WORD OF SAIL MEMORY BLOCK.
00500	;ACCUMULATOR-3  SIZE OF SAIL MEMORY BLOCK.
00600	LISP:	DAC 0,AC0
00700		LAC 0,[XWD 1,AC1]
00800		BLT 0,AC17
00900		LAC 3,-1(17)
01000		PUSHJ 17,CORGET
01100		JFCL
01200	;JSR ALLOCD ;Allocation dialogue.
01300	OUTSTR [ASCIZ/
01400	/]
01500		
01600	;Bottom, Size & Top of LISP memory space.
01700		lac B,2↔lac S,3↔lac T,B
02000		addi T,-1(S)
02050		movei 1(B)↔dip B,0↔setzm(B)↔blt(T)
02100	
02200	;Take BPS off the bottom
02300		dac B,orgBPS
02400		add B,sizBPS
02500		dac B,endBPS
02600		sos   endBPS
02700		sub S,sizBPS
02800	
02900	;Take SPD off the top.
03000		dac T,endSPD
03100		sub T,sizSPD
03200		dac T,orgSPD
03300		aos   orgSPD
03400		sub S,sizSPD
03500	
03600	;Compute FWS size ← 400+S/16.
03700		lac  A,S
03800		ash  A,-4
03900		addb A,sizFWS
04000	
04100	;Compute FBT size.
04200		idivi A,44
04300		addi A,2
04400		dac A,sizFBT
04500	
04600	;Compute PDL size.
04700		lac A,S
04800		ash A,-6
04900		addm A,sizPDL
     

00100	;Compute size of Halfword Bit Table and Half Word Space.
00150	
00200		sub S,sizFBT
00300		sub S,sizFWS
00400		sub S,sizPDL
00500		lac A,S
00600		idivi A,41
00700		addi A,2  ;fractional words possible fore and aft.
00800		dac A,sizHBT
00900		sub S,A
01000		dac S,sizHWS
01100	
01200	;Take Half Word Space, HWS, off the bottom.
01250	
01300		lac T,endBPS
01400		movei B,1(T)
01500		dac B,orgHWS
01600		add B,sizHWS
01700		add T,sizHWS
01800		dac T,endHWS
01900	
02000	;allocate Full Word Space, FWS above HWS.
02050	
02100		dac B,orgFWS
02200		add B,sizFWS
02300		add T,sizFWS
02400		dac T,endFWS
02500		
02600	;allocate Halfword Bit Table, HBT above FWS.
02650	
02700		dac B,orgHBT
02800		add B,sizHBT
02900		add T,sizHBT
03000		dac T,endHBT
03100		
03200	;allocate Fullword Bit Table, FBT above HBT.
03250	
03300		dac B,orgFBT
03400		add B,sizFBT
03500		add T,sizFBT
03600		dac T,endFBT
03700		
03800	;allocate Push Down List, PDL above FBT.
03850	
03900		dac B,orgPDL
04000		add B,sizPDL
04100		add T,sizPDL
04200		dac T,endPDL
     

00100	;Initialize the values of the BPORG & BPEND atoms.
00150	
00200		LAC A,orgBPS
00300		ADDM A,VBPORG	;value of BPORG.
00400		LAC A,endBPS
00500		ADDM A,VBPEND	;value of BPEND.
00600	
00700	;Setup Special PDL pointer.
00750	
00800		LACN A,SIZSPD
00900		hrlz A,A
01000		lap A,orgSPD
01100		sos A
01200		dac A,SC2
01300	
01400	;lowest word of PDL holds pointer to OBLIST.
01450	
01500		LAC B,orgPDL
01600		LAC A,orgHWS
01700		DAC A,(B)
01800	
01900	;setup regular PDL pointer.
01950	
02000		ADDI B,12
02100		DAP B,C2
02200		LACN C,SIZPDL
02300		ADDI C,20
02400		DIP C,C2
02500	
02600	;Fixup references to HWS.
02650	
02700		lac FF,orgHWS
02750		addi FF,bckets  ;ATOMS'.
02800		subi FF,ATOMS
02900		MOVEI C,FOOLST
03000	REL5:	LAC B,(C)↔ CDR A,(B)↔ ADD A,FF↔ DAP A,(B)
03400		LIP B, B ↔ CDR A,(B)↔ ADD A,FF↔	DAP A,(B)
03800		CAIGE C,EFOLST-1
03900		AOJA C,REL5
     

00100	;Initialize the OBLIST in HWS.
00200	
00300		hrlzi A,1-bckets
00400		lap   A,orgHWS
00500		aos   A
00600		dapz  A,-1(A)
00700		aobjn A,.-1
00800	
00900	;Initialize pointers for atomic relocation.
01000	
01100		movei F,ATOMS+2		;From here.
01200		lac T,orgHWS
01300		addi T,bckets+2		;To there
01400		lac  TT,endHWS		;Top To there.
01500	FOO	hrli TT,PNAME		;PNAME property.
01600		lac  FF,orgFWS		;pname full words.
01700		lac REL,T↔sub REL,F	;relocation displacement.
01800	
01900	;Save pointer to Atom Head for OBLIST interning.
02000		tdza S,S   ;The first atom is NIL.
02100	REL0:	lac S,T
02200	
     

00100	;Relocate CAR of cell.
00200	
00300	REL1:	car A,(F)	;get From atoms.
00400		caige A,ATOME	;skip too high.
00500		caige A,ATOMS	;step too low.
00600		skipa		;not in HWS.
00700		add A,REL
00800		dip A,(T)
00900	
01000	;Relocate CDR of cell.
01050	
01100		cdr A,(F)
01200		caige A,ATOME
01300		caige A,ATOMS
01400		skipa
01500		add A,REL
01600		dap A,(T)
01700	
01800	;Advance down property list.
01900	
02000		aos F ↔ aos T	;advance pointers in Sync.
02100		jumpn A,REL1	;test for end of list.
     

00100	;Intern the atom on the OBLIST.
00200	
00300		lac A,(F)	;get 1st word of pname.
00400		lsh A,-1
00500		idivi A,bckets
00600		add B,orgHWS	;bucket pointer.
00700		car A,(B)
00800	FOO	cain S,UNBOUND
00900		jrst .+5 	; Don't intern UNBOUND.
01000		dip TT,(B)	;put a node in the bucket.
01100		dap A,(TT)
01200		dip S,(TT)	;put atom head in the node.
01300		sos TT		;new top of HWS.
01400	
01500	;Take two words off the top of HWS for PNAME property pair.
01600	
01700		dipz T,(TT)	;(pnlist . NIL)
01800		dac  TT,-1(TT)	;(PNAME . (pnlist . NIL))
01900		sos TT
02000		dap TT,-1(T)	;NCONC pname pair on property list.
02100		sosa TT		;new top of HWS and Skip.
02200	
02300	;Make pname Full Word List.
02400	
02500	REL2:	dap T,-1(T)		;PNAME list continued.
02600		lac(F)↔dac(FF)
02700		dipz FF,(T)		;put FW pointer in list.
02800		aos F ↔ aos T ↔ aos FF	;advance pointers in Sync.
02900		hlre(F)↔aose		;test for atom head, End of Ascii.
03000		jrst REL2
03100	
03200	;Mark end of PNLIST.
03300	
03400		caige F,ATOME	;End of Atoms.
03500		jrst REL0
03550		setzb F,DDTIFG
03600		jsr IOBRST
03700		jrst START
     

00100	SUBTTL TOP LEVEL AND INITIALIZATION  --- PAGE 2
00200	
00300	START:  ;CALLI RESET
00400		LAC  [JSR UUOH]
00500		EXCH JOB41
00600		MOVEM SAI41
00700		MOVEI APRINT
00800		EXCH  JOBAPR
00900		DAC   SAIAPR
01000		MOVEI APRFLG
01100		CALLI APRINI
01200		HRRZI 17,1
01300		SETZB 0,PSAV1
01400		BLT 17,17	;clear acs 
01500	LSPRT1:	SETOM ERRSW	;print error messages
01600		SETZM ERRTN	;return to top level on errors
01700		SETOM PRVCNT#	;initialize counter for errio
01800		MOVE P,C2#	;initial reg pdl ptr
01900		MOVE SP,SC2#	;initial spec pdl ptr
02000	LISP1X:	PUSHJ P,TTYRET	;(outc nil t)(inc nil t).
02100	FOO	HRROI 0,CNIL2	;initialize nil
02200		SKIPN FF+X	
02300		PUSHJ P,AGC	;garbage collect only if necessary
02400		SKIPN BSFLG#	;initial bootstrap for macros
02500		JRST BOOTS
02600		;SKIPE RETFLG	;test for error return
02700		;JRST [	SKIPE A,INITF
02800		;	CALLF (A)	;evaluate initialization function
02900		;	SETZM RETFLG
03000		;	JRST .+1]
03100	LISP2:	PUSHJ P,TTYRET		;return all i/o to tty
03200		PUSHJ P,TERPRI
03300		SKIPE GOBF#	;garbaged oblist flag
03400		STRTIP [SIXBIT /GARBAGED OBLIST←!/]
03500		SETZM GOBF
03600		SKIPE BPSFLG#
03700		JRST BINER2	;binary program space exceeded by loader
03800	LISP1:	PUSHJ P,READ	;this is the top level of lisp
03900		PUSHJ P,EVAL
04000		PUSHJ P,PRINT
04100		PUSHJ P,TERPRI
04200		JRST LISP1
     

00100	INITFN:	EXCH A,INITF#
00200		POPJ P,
00300	
00400	;return from lisp error or bell
00500	LSPRET:	PUSHJ P,TERPRI
00600		SKIPE PSAV1#	;bell from alvine?
00700		JRST [	MOVE P,PSAV1	;yes, return to alvine
00800			CDR REL,ED
00900			JRST 1(REL)]	;improved magic
01000		MOVE B,SC2
01100		PUSHJ P,UBD	;unbind specpdl
01200		SETOM RETFLG	;set return flag
01300		JRST LSPRT1
01400	
01500	.RSET:	EXCH A,RSTSW#
01600		POPJ P,
01700	
01800	;bootstrapper for macro definitions
01900	BOOTS:	SETOM BSFLG
02000		MOVEI A,BSTYI
02100		PUSHJ P,READP1
02200		PUSHJ P,EVAL
02300		PUSHJ P,READ
02400		JRST .-2
02500	
02600	BSTYI:	ILDB A,[POINT 7,[ASCII /(INC(INPUT SYS:(LISP.LSP)))/]]
02700		POPJ P,
     

00100	SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
00200	;arithmetic processor interupts
00300	;mem. protect. violation, nonex. mem. or pdl overflow
00400	
00500	APRINT:	MOVE R,JOBCNI	;get interupt bits
00600		TRNE R,MPV+NXM	;what kind
00700		ERR3 @JOBTPC	;an ill mem ref-will become JRST ILLMEM
00800		JUMPN NIL,MES21	;a pdl overflow
00900		STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
01000		JRST START
01100	
01200	MES21:	SETZM JOBUUO
01300		SKIPL P
01400		STRTIP [SIXBIT /←REG !/]
01500		SKIPL SP
01600		STRTIP [SIXBIT /←SPEC !/]
01700		SKIPE JOBUUO
01800	SPDLOV:	ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
01900		TRNE R,PDOV
02000		SKIPE JOBUUO
02100		HALT		;lisp should not be here
02200	BINER2:	SETZM BPSFLG
02300		ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
02400	
02500	ILLMEM:	LDB R,[POINT 4,@JOBTPC,XFLD];get index field of bad word
02600		CAIE R,F	;does  it contain f
02700		ERR3 @JOBTPC	;no! error
02800		PUSHJ P,AGC	;yes! garbage collect
02900		JRST @JOBTPC	;and continue
     

00100	SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
00200	
00300	UUOMIN←←1
00400	UUOMAX←←4
00500	
00600	UUOH:	X		;jsr location
00700		MOVEM T,TSV#
00800		MOVEM TT,TTSV#
00900			LDB T,[POINT 9,JOBUUO,OPFLD]	;get opcode
01000		CAIGE T,34	;is it a function call
01100		JRST ERROR	;or a LISP error
01200		HLRE R,@JOBUUO
01300		AOJN R,UUOS
01400		LDB T,[POINT 4,JOBUUO,ACFLD]
01500		CAILE T,15
01600		MOVEI R,-15(T)
01700		CDR T,@JOBUUO
01800	UUOH1:	CAR TT,(T)
01900		CDR T,(T)
02000	FOO	CAIN TT,SUBR
02100		JRST @UUST(R)
02200	FOO	CAIN TT,FSUBR
02300		JRST @UUFST(R)
02400	FOO	CAIN TT,LSUBR
02500		JRST @UULT(R)
02600	FOO	CAIN TT,EXPR
02700		JRST @UUET(R)
02800	FOO	CAIN TT,FEXPR
02900		JRST @UUFET(R)
03000		CDR T,(T)
03100		JUMPN T,UUOH1
03200		PUSH P,A
03300		PUSH P,B
03400		CDR A,JOBUUO
03500	FOO	MOVEI B,VALUE
03600		PUSHJ P,GET
03700		JUMPN A,[	CDR TT,(A)
03800				POP P,B
03900				POP P,A
04000				JRST UUOEX1]
04100		CDR A,JOBUUO
04200		PUSHJ P,EPRINT
04300		ERR1 [SIXBIT /UNDEFINED UUO!/]
     

00100		SKIPA T,TT
00200	UUOSBR:	CAR T,(T)
00300		MOVE TT,JOBUUO
00400		HRLI T,(<PUSHJ P,>)
00500		TLNE TT,1000	;1000 means no push
00600		TLCA T,34600	;<PUSHJ P,>xor<JRST>
00700		PUSH P,UUOH
00800		SOS UUOH
00900	UUOCL:	TLNN TT,2000+X	;2000 means no clobber
01000		MOVEM T,@UUOH
01100		MOVE TT,TTSV
01200		EXCH T,TSV
01300		JRST @TSV
01400	
01500	UUOS:	CDR TT,JOBUUO
01600		CAMLE TT,orgHWS
01700		CAML TT,orgFWS
01800		JRST UUOSBR-1
01900		JRST .+2
02000	UUOEXP:	CAR TT,(T)
02100	UUOEX1:	LDB T,[POINT 5,JOBUUO,ACFLD]
02200		TRZN T,20
02300		PUSH P,UUOH
02400		PUSH P,TT
02500		JUMPE T,IAPPLY
02600		CAIN T,17
02700		MOVEI T,1
02800		MOVNS T
02900		HRLZ TT,T
03000		PUSH P,A(TT)
03100		AOBJN TT,.-1
03200		JRST IAPPLY
     

00100	ARGPDL:	LDB T,[POINT 4,JOBUUO,ACFLD]
00200		MOVNS T
00300		HRLZ R,T
00400	ARGP1:	JUMPE R,(TT)
00500		PUSH P,A(R)
00600		AOBJN R,.-1
00700		JRST (TT)
00800	
00900	QTIFY:	PUSHJ P,NCONS
01000	FOO	MOVEI B,CQUOTE
01100		JRST XCONS
01200	
01300	QTLFY:	MOVEI A,0
01400	QTLFY1:	JUMPE T,(TT)
01500		EXCH A,(P)
01600		PUSHJ P,QTIFY
01700		POP P,B
01800		PUSHJ P,CONS
01900		AOJA T,QTLFY1
02000	
02100	PDLARG:	JRST .+NACS+2(T)
02200		POP P,A+5
02300		POP P,A+4
02400		POP P,A+3
02500		POP P,A+2
02600		POP P,A+1
02700		POP P,A
02800		JRST (TT)
02900	
03000	NOUUO:	MOVSI B,(<TLNN TT,>)
03100		SKIPE A
03200		MOVSI B,(<TLNA>)
03300		HLLM B,UUOCL
03400		EXCH A,NOUUOF#
03500		POPJ P,
     

00100	;r←0 ←> compiler calling a -
00200	;r←1 ←> compiler calling a lsubr
00300	;r←2 ←> compiler calling f type
00400	UUST:	UUOSBR
00500		UUOS1	;calling l its a subr
00600		UUOS2	;calling f
00700	
00800	
00900	UUFST:	UUOS9	;calling - its a f
01000		UUOS10	;calling l
01100		UUOSBR
01200	
01300	UULT:	UUOS7	;calling - its a l
01400		UUOSBR
01500		UUOS8
01600	
01700	UUET:	UUOEXP
01800		UUOS5	;calling l its an expr
01900		UUOS6	;calling f its an expr
02000	
02100	UUFET:	UUOS3	;calling - its a fexpr
02200		UUOS4	;calling l
02300		UUOEXP	
02400	
02500	UUOS1:	CAR R,(T)
02600		MOVE T,TSV
02700		JSP TT,PDLARG
02800		JRST (R)
02900	
03000	UUOS3:	PUSH P,(T)
03100		JSP TT,ARGPDL
03200	UUOS4A:	JSP TT,QTLFY
03300		MOVEI TT,1
03400		DPB TT,[POINT 4,JOBUUO,ACFLD]
03500	UUOS6A:	POP P,TT
03600		HLRZS TT
03700		JRST UUOEX1
03800	
03900	UUOS4:	PUSH P,(T)
04000		MOVE T,TSV
04100		JRST UUOS4A
     

00100	UUOS5:	CAR R,(T)
00200		MOVE T,TSV
00300		JSP TT,PDLARG
00400		MOVE TT,R
00500		JRST UUOEX1
00600	
00700	UUOS6:	PUSH P,(T)
00800		PUSH P,UUOH
00900		PUSH P,JOBUUO
01000		JSP TT,ILIST
01100		JSP TT,PDLARG
01200		POP P,JOBUUO
01300		POP P,UUOH
01400		JRST UUOS6A
01500	UUOS8:	SKIPA TT,CILIST
01600	UUOS7:	MOVEI TT,ARGPDL
01700		DAP TT,UUOS7A
01800		MOVE TT,JOBUUO
01900		TLNN TT,1000
02000		PUSH P,UUOH
02100		CAR TT,(T)
02200	UUOS7A:	JRST ARGPDL+X	;or ilist
02300	
02400	UUOS9:	PUSH P,T
02500		JSP TT,ARGPDL
02600	UUS10A:	JSP TT,QTLFY
02700		MOVSI T,2000
02800		IORM T,JOBUUO
02900		POP P,T
03000		JRST UUOSBR
03100	
03200	UUOS10:	PUSH P,T
03300		MOVE T,TSV
03400		JRST UUS10A
03500	
     

00100	SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 5
00200	;subroutine to print sixbit error message
00300	ERRSUB:	MOVSI A,(<POINT 6,0>)
00400		HRR A,JOBUUO
00500		MOVEM A,ERRPTR#
00600	ERRORB:	ILDB A,ERRPTR
00700		CAIN A,01	;conversion from sixbit
00800		POPJ P,
00900		CAIN A,77
01000		JRST [	PUSHJ P,TERPRI
01100			JRST ERRORB]
01200		ADDI A,40
01300		PUSHJ P,TYO
01400		JRST ERRORB
01500	
01600	;subroutine to return output to previously selected device
01700	OUTRET:	SKIPL PRVCNT	;if prvcnt<0 then no device deselect.
01800		SOSL PRVCNT	;when prvcnt goes negative, then reselect
01900		POPJ P,
02000		PUSH P,PRVSEL#		;previously selected output
02100		POP P,TYOD
02200		POPJ P,
02300	
02400	;subroutine to force error messages out on tty
02500	ERRIO:	MOVE B,ERRSW
02600		CAIE B,INUM0	;INUM0 means use selected device.
02700		AOSLE PRVCNT	;if prvcnt<0 then deselect.
02800		POPJ P,	
02900		TALK		;undo control o
03000		MOVE B,[JRST TTYO]
03100		EXCH B,TYOD
03200		MOVEM B,PRVSEL
03300		POPJ P,
03400	
03500	ERRTN:	0	;0 ←> top level				*
03600		;- ←> pdl to reset to - stored by errorset
03700		;+ ←> string tyo pout rtn flag
03800	ERRSW:	-1	;0 means no prnt on error		*
     

00100	;subroutine to search oblist for closest function to address in r
00200	ERSUB3:
00300	FOO	MOVEI A,QST
00400	FOO	HRROI NIL,CNIL2
00500		HRLZI B,BCKETS
00600		MOVNS B
00650		LAP   B,orgHWS
00700		SETZB AR2A,GOBF
00800		PUSH P,JOBAPR
00900		MOVEI C,[	SETOM GOBF
01000				JRST ERRO2G]
01100		DAP C,JOBAPR
01200		CAR C,(B)
01300	ERRO2B:	JUMPE C,[	AOBJN B,.-1
01400				POP P,JOBAPR	;oblist done, restore
01500				JRST PRINC]	;print closest match
01600		CAR TT,(C)
01700	ERRO2C:	CDR TT,(TT)
01800		JUMPE TT,ERRO2G
01900		CAR AR1,(TT)
02000	FOO	CAIN AR1,LSUBR
02100		JRST ERRO2H
02200	FOO	CAIE AR1,SUBR
02300	FOO	CAIN AR1,FSUBR
02400		JRST ERRO2H
02500		CDR TT,(TT)
02600		JRST ERRO2C
02700	
02800	ERRO2H:	CDR TT,(TT)
02900		CAR TT,(TT)
03000		CAMLE TT,AR2A	;le to prefer car to quote
03100		CAMLE TT,R
03200		JRST ERRO2G
03300		MOVE AR2A,TT
03400		CAR A,(C)
03500	ERRO2G:	CDR C,(C)
03600		JRST ERRO2B
     

00100	;dispatcher for error message uuos
00200	ERROR:	MOVEI A,APRFLG
00300		CALLI A,APRINI	;enable interupts
00400		LDB A,[POINT 9,JOBUUO,OPFLD]	;get opcode
00500		CAIL A,UUOMIN	;what
00600		CAILE A,UUOMAX	;is it?
00700		JRST ILLUUO	;an illegal opcode
00800		JRST @ERRTAB-UUOMIN(A)	;or LISP error
00900	ERRTAB:	ERROR1	;1	;ordinary LISP error
01000		ERRORG	;2	;space overflow error
01100		ERROR2	;3	;ill. mem. ref.
01200		STRTYP	;4	;print error message and continue
01300	ERRORG:	SKIPN P,ERRTN	;if in errset, restore p to that level
01400		MOVE P,C2	;else to top level
01500				;and attempt to print message
01600	
01700	ERROR1:	SKIPN ERRSW
01800		JRST ERREND	;dont print message, call (err nil)
01900		PUSHJ P,ERRIO	;print message on tty
02000		PUSHJ P,TERPRI
02100		PUSHJ P,ERRSUB	;print the message
02200		JRST ERRBK	;go the backtrace
02300	
02400	STRTYP:	PUSHJ P,ERRIO
02500		PUSHJ P,ERRSUB	;print message and continue
02600		PUSHJ P,OUTRET
02700		JRST @UUOH
     

00100	ERROR2:	CDR A,JOBUUO
00200		MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
00300		JRST ERSUB2
00400	
00500	ILLUUO:	CDR A,UUOH
00600		MOVEI B,[SIXBIT / ILL UUO FROM !/]
00700	ERSUB2:	SKIPN ERRSW
00800		JRST ERREND	;dont print message
00900		PUSH P,A
01000		PUSH P,B
01100		PUSHJ P,ERRIO
01200		PUSHJ P,TERPRI
01300		PUSHJ P,PRINL2	;print number
01400		POP P,A
01500		STRTIP (A)	;print message
01600		POP P,R
01700		PUSHJ P,ERSUB3	;print nearest oblist match
01800	ERRBK:	SKIPE BACTRF#
01900		PUSHJ P,BKTRC	;print backtrace
02000		PUSHJ P,OUTRET	;return to previous device
02100	ERREND:	MOVEI A,0	;(err nil)
02200		SKIPN ERRTN
02300		JRST	[CLRBFI	;clear INPUT buffer
02400			SKIPE RSTSW
02500			JRST LISP2  ;(*rset t) goes to 
02600			 ;read-eval-print loop without unbinding.
02700			JRST LSPRET]	;unbind and go to top level
02800	ERR:	SKIPN ERRTN
02900		JRST LSPRET ;not in an errset, or bad error -
03000				; - go to top level
03100		MOVE P,ERRTN
03200	ERR1:	POP P,B
03300		PUSHJ P,UBD	;unbind to previous errset
03400		POP P,ERRSW
03500		POP P,ERRTN
03600		JRST ERRP4	;and proceed
03700	
03800	ERRSET:	PUSH P,PA3
03900		PUSH P,PA4
04000		PUSH P,ERRTN
04100		PUSH P,ERRSW
04200		PUSH P,SP
04300		MOVEM P,ERRTN
04400		CDR C,(A)
04500		CAR C,(C)
04600		MOVEM C,ERRSW
04700		CAR A,(A)
04800		PUSHJ P,EVAL
04900		PUSHJ P,NCONS
05000		JRST ERR1
     

00100	;error messages
00200	
00300	DOTERR:	SETZM OLDCH
00400		ERR1 [	SIXBIT /DOT CONTEXT ERROR!/]
00500	UNDFUN:	CAR A,(AR1)
00600		PUSHJ P,EPRINT
00700		ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
00800	UNBVAR:	PUSHJ P,EPRINT
00900		ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
01000	NONNUM:	ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
01100	NOPNAM:	ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
01200	NOLIST:	ERR1 [SIXBIT /NO LIST-MAKNAM!/]
01300	TOMANY:	ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
01400	TOOFEW:	ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
01500	UNDTAG:	PUSHJ P,EPRINT
01600		ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
01700	EG1:	CDR A,T
01800		PUSHJ P,EPRINT
01900		ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
     

00100	;backtrace subroutine
00200	BKTRC:	MOVEI D,-1(P)
00300		MOVN A,BACTRF
00400		ADDI A,INUM0
00500		JUMPL A,[	ADD A,P	;backtrace specific number 
00600				JRST .+3]
00700		SKIPN A,ERRTN	;backtrace to previous errset
00800		MOVE A,C2	;or top level
00900		DAPZ A,BAKLEV#
01000		STRTIP [SIXBIT /←BACKTRACE←!/]
01100	BKTR2:	CAMG D,BAKLEV
01200		JRST FALSE	;done 
01300		CDR A,(D)	;get pdl element
01400		CAMGE A,orgHWS
01500		JUMPN A,.+2	;this is (hopefully) a true program address
01600		SOJA D,BKTR2	;not a program address, continue
01700		CAIN A,ILIST3
01800		JRST BKTR1A	;argument evaluation 
01900	BKTR1B:	CAIN A,CPOPJ
02000		JRST [	CAR A,(D)	;calling a function
02100			PUSHJ P,PRINC
02200			XCT "-",CTY
02300			STRTIP [SIXBIT /ENTER !/]
02400			SOJA D,BKTR2]
02500		CAR B,-1(A)
02600		CAILE B,(<JCALLF 17,@(17)>)
02700		CAIN B,(<PUSHJ P,>)	;tests for various types of calls
02800		CAIGE B,(<FCALL>)
02900		SOJA D,BKTR2		;not a proper function call
03000		PUSH P,-1(A)	;save object of function call
03100		MOVEI R,-1(A)	;location of function call
03200		PUSHJ P,ERSUB3		;print closest oblist match
03300		MOVEI A,"-"
03400		PUSHJ P,TYO
03500		POP P,R
03600		TLNE R,17
03700		CDR R,ERSUB3	;qst -- cant handle indexed calls
03800		HRRZS R
03900		HLRO B,(R)
04000		AOSN B
04100		JRST [	CDR A,R	;was calling an atomic function
04200			PUSHJ P,PRINC	;print its name
04300			JRST .+2]
04400		PUSHJ P,ERSUB3	;was calling a code location -
04500				; - print closest match
04600		MOVEI A," "
04700		PUSHJ P,TYO
04800	BKTR1:	SOJA D,BKTR2	;continue
04900	
05000	BKTR1A:	CDR B,-1(D)
05100		CAIE B,EXP2
05200		CAIN B,ESB1
05300		JRST .+2
05400		JRST BKTR1B	;hum, not really evaluating arguments
05500		HLRE B,-1(D)
05600		ADD B,D
05700		CAR A,-3(B)
05800		JUMPE A,BKTR1
05900		PUSHJ P,PRINC
06000		XCT "-",CTY
06100		STRTIP [SIXBIT /EVALARGS !/]
06200		JRST BKTR1
06300	
06400	BAKGAG:	EXCH A,BACTRF
06500		POPJ P,